Intro

This document contains various maps showing adoption data from the Cincinnati Animal CARE shelter built to help plan for their participation in the Competitive Pet Placement project.

The data visualized here was obtained and processed as follows:

  1. A CAC outcomes report filtered to include only Adoption outcomes from 2020-07-01 through 2023-09-30 served as the raw data.

  2. Some additional cleaning was done, primarily removing apartment numbers from the street address column by removing all characters appearing after a comma.

  3. The file was then geocoded using the Census Geocoder, which also prorvides a Census Tract for each geocoded address. 12189 (95%) out of the 12757 adoption records were geocoded successfully. The rest (which were spread across all years of data) were excluded from the analysis.

  4. LOS was calculated using outcome date minus intake date and grouped into 0-30, 31-90, and 91+ days.

  5. To narrow down the mapping, only addresses from OH (10471), KY (1376), and IN (253) were included, excluding 89 addresses from outside these states. The final dataset contains 12,100 geocoded adoption outcomes.

  6. Census data for all tracts in which adoption outcomes occurred were retrieved from the Census API based on the received guidance - other variables can be added easily.

  7. Maps focus on dogs based on our understanding of the area of most potential.

All Adoptions (dogs)

This first map shows all adoptions in the data (Total) as well as adoptions per 1000 households, to account for the fact that places with more households are expected to have more adoptions. Note that there are a few area with many adoptions and unusually low household count in the census data (I double checked it), not sure what’s going on there but just note that these are by far higher than the rest of the data (as you can see when exploring the map).

# create total adoption
sf_all <- 
  dfmap %>%
  filter(Species=='Dog') %>%
  count(GEOID) %>%
  left_join(census_df %>% select(GEOID, geometry), by='GEOID') %>% st_as_sf()

# create color palette
pal_all <- colorBin(palette='Purples', domain = sf_all$n, bins = c(0, 20, 40, 80, 160))

# create tooltip label
label_all <- sprintf("Tract %s<br/><strong>%g %s</strong>",
                     str_sub(sf_all$GEOID,-6,-1), sf_all$n, 'Adoptions') %>% lapply(htmltools::HTML)

# create per households df
sf_percap <- 
  dfmap %>%
  filter(Species=='Dog') %>%
  count(GEOID) %>%
  left_join(census_df %>% select(GEOID, pop, households, geometry), by='GEOID') %>% 
  filter(households!=0) %>% # 13 geoids
  mutate(per=round(n/households*1000)) %>%
  st_as_sf()

# color palette and label - need to adjust for some really high # bc low household count
pal_percap <- colorBin(palette='Purples', domain = sf_percap$per, bins = c(0, 10, 25, 50, 100, 500, 1000))
label_percap <- sprintf("Tract %s<br/><strong>%g %s</strong>", str_sub(sf_percap$GEOID,-6,-1),
                        sf_percap$per, 'Adoptions per<br/>1000 households') %>% lapply(htmltools::HTML)


# all adoptions map
leaflet() %>%
  addTiles() %>%
  setView(lat = shelter_lat, lng = shelter_lng, zoom=10) %>% # CAC location
  addMarkers(lat = shelter_lat, lng = shelter_lng, label='Cincinnati Animal CARE') %>%
  addPolygons(data=fix_sf(sf_all), group='Total', fillColor=~pal_all(n),
              fillOpacity = 0.8, color='grey', weight = 1, opacity = 0.4, label = label_all,
              highlightOptions = highlightOptions(color = "black",weight = 2, bringToFront = TRUE)) %>%
  addPolygons(data=fix_sf(sf_percap), group='Household', fillColor=~pal_percap(per),
              fillOpacity = 0.8, color='grey', weight = 1, opacity = 0.4, label = label_percap,
              highlightOptions = highlightOptions(color = "black",weight = 2, bringToFront = TRUE)) %>%
  addLegend(pal = pal_all, values = sf_all$n, opacity = 0.8, title = 'Total Adoptions',
            position = "bottomright", group='Total') %>%
  addLegend(pal = pal_percap, values = sf_percap$per, opacity = 0.8, title = 'Adoptions per<br>1000 Households',
            position = "bottomleft", group='Household') %>%
  addLayersControl(
    baseGroups = c('Total','Household'),
    options = layersControlOptions(collapsed = FALSE)
  ) %>%
  hideGroup(c('Household'))

Adoptions by Year (dogs)

Each layer shows a heatmap of adoptions that took place in a particular year.

Adoptions by Species / Size

Species

This maphows all dog and cat adoptions for comparison.

Size

Each layer shows a heatmap of adoptions of dogs of each size category. Extra Large animals were merged into Large.

Census data

I broke down the data into two maps: one that has language data and another that has other demographic data. Layering these and the adoption data is possible but to make it visually helpful is not straightforward, so once we’re more focused we could consider if that is needed.

Demographics

Below Poverty 100% refers to the % of residents that are below the federal poverty line, and Owner Occupied is similarly represented as a percent value of residents.

Languages

Values in the pop-ups for each Census Tract represent the % of the population that speaks this language well AND does not speak english well.